Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/tcl/spectcl-.000/spectcl-/usr/local/SpecTcl-0.1a/menu.tk

Text File | 1995-11-06 | 5.3 KB | 188 lines

# SpecTcl, by S. A. Uhler
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
#
# See the file "license.txt" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# These commands are called via the menubar.  The goal is to have all
# "-command" options of widgets and menus (and bindings) consist entirely
# of procedure calls with aruments, so we can create test cases in batch
# files by simulating events and button/menu invocations

# toggle the grid lines

proc toggle_grid {} {
    global Frames Grid
    foreach i [array names Frames] {
        grid_resize $i $Grid
        update_table $i grid
        }
    }

# Copy the selected widget to the clipboard

proc to_clipboard {} {
    global Current _Message
    if {$Current(widget) != ""} {
        upvar #0 [winfo name $Current(widget)] data
        set append "array set SpecTcl_widget \{"
        foreach i [array names data] {
            lappend append $i $data($i)
        }
        append append \}
        clipboard clear
        clipboard append $append
        set _Message "Copying $data(item_name) to clipboard"
    }
}

# paste the clipboard item into the current canvas (gulp)
# This is still broken

proc from_clipboard {{test 0}} {
    global Current SpecTcl_widget Next_widget
    if {!$test} {global _Message}

    if {[catch {set widget [selection get -selection CLIPBOARD]}]} {
        set _Message "No data on clipboard"
        return 0
    }
    if {![regexp SpecTcl_widget $widget] || [catch {eval $widget}]} {
        set _Message "Invalid data on clipboard"
        return 0
    }

    if {$test} {return 1}

    # change the appopriate widget parameters and put the
    # widget in a "hidden" spot

    set type $SpecTcl_widget(type)
    set name $SpecTcl_widget(item_name)

    # for consistency with copy
    set SpecTcl_widget(rowspan) 1
    set SpecTcl_widget(columnspan) 1

    set SpecTcl_widget(row) 0
    set SpecTcl_widget(column) 0
    set SpecTcl_widget(master) ""
    catch {destroy .clipboard}
    frame .clipboard
    set new [widget_configure SpecTcl_widget .clipboard]

    # figure out where to put it
    # 1) if a widget is selected, delete it and put new one there
    # 2) if a row and column are selected, put it there
    # 3) if a row or column is selected, put in first empty cell (later)
    # 4) punt

    if {$Current(widget) != ""} {
        scan [blt_table info $Current(widget)] "%*s %d,%d" row col
        delete_selected 0
    } elseif {$Current(row) != "" && $Current(column) != ""} {
        regsub {[^_]*_} $Current(row) {} row
        regsub {[^_]*_} $Current(column) {} col
        if {[blt_table slaves $Current(frame) -row $row -column $col] != ""} {
            set _Message "Selected position is already occupied"
            return 0
        }
    } else {
        set _Message "No where to put widget!"
        return 0
    }
    set win [copy_widget $Current(frame) $new $row,$col]
    set_master $win $Current(frame)
    upvar #0 [winfo name $win] data
    if {!([regexp # $name] || [have_name $name])} {
        set data(item_name) $name
    }
    unselect_widget
    select_widget $win
    destroy .clipboard
    set _Message "Pasting $data(item_name)"
}

# bring up generic menu option sheet affiliated with selected widget

proc menu_generic {} {
    global Current _Message
    if {$Current(widget) != ""} {
        upvar #0 [winfo name $Current(widget)] data
        activate_generic $data(type)
    } else {
        set _Message "No widget is selected"
        bell
    }
}

# bring up widget menu option sheet

proc menu_widget {} {
    global Current _Message
    if {$Current(widget) != ""} {
        upvar #0 [winfo name $Current(widget)] data
        activate_option $Current(widget)
    } else {
        set _Message "No widget is selected"
        bell
    }
}

# set the proper menu optiond to active/inactive

proc editmenu_active {} {
    global Current

    # options that need a selected widget

    set state [expr {$Current(widget) == "" ? "disabled" : "normal"}]
    foreach i {{Widget options ...} {Generic options ...} Cut Copy} {
        [menubar_getmenuname .menu $i] entryconfigure $i -state $state
    }

    set state [expr {"$Current(widget)$Current(row)$Current(column)" == "" ? "disabled" : "normal"}]
    [menubar_getmenuname .menu Delete] entryconfigure Delete -state $state

    set state [expr {![from_clipboard 1]? "disabled" : "normal"}]
    [menubar_getmenuname .menu Paste] entryconfigure Paste -state $state
}

proc commandmenu_active {} {
    global Current Widgets

    if {[catch {send $Current(test_app) pid}]} {set state disabled} {set state normal}
    [menubar_getmenuname .menu "Kill test"] entryconfigure "Kill test" -state $state

    if {[array size Widgets] == 0} {set state disabled } { set state normal}
    [menubar_getmenuname .menu "Build & Test"] entryconfigure "Build & Test" -state $state

    if {[llength [array names Widgets scrollbar#*]] == 0} {set state disabled } { set state normal}
    [menubar_getmenuname .menu "Attach scrollbars"] entryconfigure "Attach scrollbars" -state $state

    if {$Current(repeat) == ""} {set state disabled } { set state normal}
    [menubar_getmenuname .menu "Re-apply toolbar"] entryconfigure "Re-apply toolbar" -state $state
}

# set up the html help

# add a "box" tag to put a box around the text
array set HMtag_map {box {Tbox box}}

proc html_help {{file help.html}} {
    global _Message Help_history
    set Help_history ""
    set _Message "Loading help..."
    update idletasks
    catch {destroy .help}
    help_ui [toplevel .help]
    update
    HMinit_win .help.text
    # HMset_indent $win 2.2
    # set <dt> text in magenta
    .help.text tag configure hi -foreground magenta
    .help.text tag configure box -borderwidth 3 -relief ridge
    HMlink_callback .help.text $file
    set _Message ""
}